home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / sparc / move.lisp < prev    next >
Encoding:
Text File  |  1992-01-14  |  9.3 KB  |  326 lines
  1. ;;; -*- Package: SPARC -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the Spice Lisp project at
  5. ;;; Carnegie-Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of Spice Lisp, please contact
  7. ;;; Scott Fahlman (FAHLMAN@CMUC). 
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: move.lisp,v 1.3 92/01/14 16:08:19 ram Exp $
  11. ;;;
  12. ;;;    This file contains the SPARC VM definition of operand loading/saving and
  13. ;;; the Move VOP.
  14. ;;;
  15. ;;; Written by Rob MacLachlan.
  16. ;;; SPARC conversion by William Lott.
  17. ;;;
  18. (in-package "SPARC")
  19.  
  20.  
  21. (define-move-function (load-immediate 1) (vop x y)
  22.   ((null immediate zero)
  23.    (any-reg descriptor-reg))
  24.   (let ((val (tn-value x)))
  25.     (etypecase val
  26.       (integer
  27.        (inst li y (fixnum val)))
  28.       (null
  29.        (move y null-tn))
  30.       (symbol
  31.        (load-symbol y val))
  32.       (character
  33.        (inst li y (logior (ash (char-code val) type-bits)
  34.               base-char-type))))))
  35.  
  36. (define-move-function (load-number 1) (vop x y)
  37.   ((immediate zero)
  38.    (signed-reg unsigned-reg))
  39.   (inst li y (tn-value x)))
  40.  
  41. (define-move-function (load-base-char 1) (vop x y)
  42.   ((immediate) (base-char-reg))
  43.   (inst li y (char-code (tn-value x))))
  44.  
  45. (define-move-function (load-system-area-pointer 1) (vop x y)
  46.   ((immediate) (sap-reg))
  47.   (inst li y (sap-int (tn-value x))))
  48.  
  49. (define-move-function (load-constant 5) (vop x y)
  50.   ((constant) (descriptor-reg))
  51.   (loadw y code-tn (tn-offset x) other-pointer-type))
  52.  
  53. (define-move-function (load-stack 5) (vop x y)
  54.   ((control-stack) (any-reg descriptor-reg))
  55.   (load-stack-tn y x))
  56.  
  57. (define-move-function (load-number-stack 5) (vop x y)
  58.   ((base-char-stack) (base-char-reg)
  59.    (sap-stack) (sap-reg)
  60.    (signed-stack) (signed-reg)
  61.    (unsigned-stack) (unsigned-reg))
  62.   (let ((nfp (current-nfp-tn vop)))
  63.     (loadw y nfp (tn-offset x))))
  64.  
  65. (define-move-function (store-stack 5) (vop x y)
  66.   ((any-reg descriptor-reg) (control-stack))
  67.   (store-stack-tn y x))
  68.  
  69. (define-move-function (store-number-stack 5) (vop x y)
  70.   ((base-char-reg) (base-char-stack)
  71.    (sap-reg) (sap-stack)
  72.    (signed-reg) (signed-stack)
  73.    (unsigned-reg) (unsigned-stack))
  74.   (let ((nfp (current-nfp-tn vop)))
  75.     (storew x nfp (tn-offset y))))
  76.  
  77.  
  78. ;;;; The Move VOP:
  79. ;;;
  80. (define-vop (move)
  81.   (:args (x :target y
  82.         :scs (any-reg descriptor-reg zero null)
  83.         :load-if (not (location= x y))))
  84.   (:results (y :scs (any-reg descriptor-reg)
  85.            :load-if (not (location= x y))))
  86.   (:effects)
  87.   (:affected)
  88.   (:generator 0
  89.     (move y x)))
  90.  
  91. (define-move-vop move :move
  92.   (any-reg descriptor-reg)
  93.   (any-reg descriptor-reg))
  94.  
  95. ;;; Make Move the check VOP for T so that type check generation doesn't think
  96. ;;; it is a hairy type.  This also allows checking of a few of the values in a
  97. ;;; continuation to fall out.
  98. ;;;
  99. (primitive-type-vop move (:check) t)
  100.  
  101. ;;;    The Move-Argument VOP is used for moving descriptor values into another
  102. ;;; frame for argument or known value passing.
  103. ;;;
  104. (define-vop (move-argument)
  105.   (:args (x :target y
  106.         :scs (any-reg descriptor-reg zero null))
  107.      (fp :scs (any-reg)
  108.          :load-if (not (sc-is y any-reg descriptor-reg))))
  109.   (:results (y))
  110.   (:generator 0
  111.     (sc-case y
  112.       ((any-reg descriptor-reg)
  113.        (move y x))
  114.       (control-stack
  115.        (storew x fp (tn-offset y))))))
  116. ;;;
  117. (define-move-vop move-argument :move-argument
  118.   (any-reg descriptor-reg)
  119.   (any-reg descriptor-reg))
  120.  
  121.  
  122.  
  123. ;;;; ILLEGAL-MOVE
  124.  
  125. ;;; This VOP exists just to begin the lifetime of a TN that couldn't be written
  126. ;;; legally due to a type error.  An error is signalled before this VOP is
  127. ;;; so we don't need to do anything (not that there would be anything sensible
  128. ;;; to do anyway.)
  129. ;;;
  130. (define-vop (illegal-move)
  131.   (:args (x) (type))
  132.   (:results (y))
  133.   (:ignore y)
  134.   (:vop-var vop)
  135.   (:save-p :compute-only)
  136.   (:generator 666
  137.     (error-call vop object-not-type-error x type)))
  138.  
  139.  
  140.  
  141. ;;;; Moves and coercions:
  142.  
  143. ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
  144. ;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
  145. ;;; to a tagged bignum or fixnum.
  146.  
  147. ;;; Arg is a fixnum, so just shift it.  We need a type restriction because some
  148. ;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
  149. ;;;
  150. (define-vop (move-to-word/fixnum)
  151.   (:args (x :scs (any-reg descriptor-reg)))
  152.   (:results (y :scs (signed-reg unsigned-reg)))
  153.   (:arg-types tagged-num)
  154.   (:note "fixnum untagging")
  155.   (:generator 1
  156.     (inst sra y x 2)))
  157. ;;;
  158. (define-move-vop move-to-word/fixnum :move
  159.   (any-reg descriptor-reg) (signed-reg unsigned-reg))
  160.  
  161. ;;; Arg is a non-immediate constant, load it.
  162. (define-vop (move-to-word-c)
  163.   (:args (x :scs (constant)))
  164.   (:results (y :scs (signed-reg unsigned-reg)))
  165.   (:note "constant load")
  166.   (:generator 1
  167.     (inst li y (tn-value x))))
  168. ;;;
  169. (define-move-vop move-to-word-c :move
  170.   (constant) (signed-reg unsigned-reg))
  171.  
  172.  
  173. ;;; Arg is a fixnum or bignum, figure out which and load if necessary.
  174. (define-vop (move-to-word/integer)
  175.   (:args (x :scs (descriptor-reg)))
  176.   (:results (y :scs (signed-reg unsigned-reg)))
  177.   (:note "integer to untagged word coercion")
  178.   (:temporary (:scs (non-descriptor-reg)) temp)
  179.   (:generator 4
  180.     (let ((done (gen-label)))
  181.       (inst andcc temp x 3)
  182.       (inst b :eq done)
  183.       (sc-case y
  184.     (signed-reg
  185.      (inst sra y x 2))
  186.     (unsigned-reg
  187.      (inst srl y x 2)))
  188.       
  189.       (loadw y x bignum-digits-offset other-pointer-type)
  190.       
  191.       (emit-label done))))
  192. ;;;
  193. (define-move-vop move-to-word/integer :move
  194.   (descriptor-reg) (signed-reg unsigned-reg))
  195.  
  196.  
  197.  
  198. ;;; Result is a fixnum, so we can just shift.  We need the result type
  199. ;;; restriction because of the control-stack ambiguity noted above.
  200. ;;;
  201. (define-vop (move-from-word/fixnum)
  202.   (:args (x :scs (signed-reg unsigned-reg)))
  203.   (:results (y :scs (any-reg descriptor-reg)))
  204.   (:result-types tagged-num)
  205.   (:note "fixnum tagging")
  206.   (:generator 1
  207.     (inst sll y x 2)))
  208. ;;;
  209. (define-move-vop move-from-word/fixnum :move
  210.   (signed-reg unsigned-reg) (any-reg descriptor-reg))
  211.  
  212.  
  213. ;;; Result may be a bignum, so we have to check.  Use a worst-case cost to make
  214. ;;; sure people know they may be number consing.
  215. ;;;
  216. (define-vop (move-from-signed)
  217.   (:args (arg :scs (signed-reg unsigned-reg) :target x))
  218.   (:results (y :scs (any-reg descriptor-reg)))
  219.   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
  220.   (:note "signed word to integer coercion")
  221.   (:generator 20
  222.     (move x arg)
  223.     (let ((fixnum (gen-label))
  224.       (done (gen-label)))
  225.       (inst sra temp x 29)
  226.       (inst cmp temp)
  227.       (inst b :eq fixnum)
  228.       (inst orncc temp zero-tn temp)
  229.       (inst b :eq done)
  230.       (inst sll y x 2)
  231.       
  232.       (with-fixed-allocation
  233.     (y temp bignum-type (1+ bignum-digits-offset))
  234.     (storew x y bignum-digits-offset other-pointer-type))
  235.       (inst b done)
  236.       (inst nop)
  237.       
  238.       (emit-label fixnum)
  239.       (inst sll y x 2)
  240.       (emit-label done))))
  241. ;;;
  242. (define-move-vop move-from-signed :move
  243.   (signed-reg) (descriptor-reg))
  244.  
  245.  
  246. ;;; Check for fixnum, and possibly allocate one or two word bignum result.  Use
  247. ;;; a worst-case cost to make sure people know they may be number consing.
  248. ;;;
  249. (define-vop (move-from-unsigned)
  250.   (:args (arg :scs (signed-reg unsigned-reg) :target x))
  251.   (:results (y :scs (any-reg descriptor-reg)))
  252.   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
  253.   (:note "unsigned word to integer coercion")
  254.   (:generator 20
  255.     (move x arg)
  256.     (let ((done (gen-label))
  257.       (one-word (gen-label)))
  258.       (inst sra temp x 29)
  259.       (inst cmp temp)
  260.       (inst b :eq done)
  261.       (inst sll y x 2)
  262.       
  263.       (pseudo-atomic (temp)
  264.     (inst add y alloc-tn other-pointer-type)
  265.     (inst add alloc-tn
  266.           (pad-data-block (1+ bignum-digits-offset)))
  267.     (inst cmp x)
  268.     (inst b :ge one-word)
  269.     (inst li temp (logior (ash 1 type-bits) bignum-type))
  270.     (inst add alloc-tn
  271.           (- (pad-data-block (+ bignum-digits-offset 2))
  272.          (pad-data-block (+ bignum-digits-offset 1))))
  273.     (inst li temp (logior (ash 2 type-bits) bignum-type))
  274.     (emit-label one-word)
  275.     (storew temp y 0 other-pointer-type)
  276.     (storew x y bignum-digits-offset other-pointer-type))
  277.       (emit-label done))))
  278. ;;;
  279. (define-move-vop move-from-unsigned :move
  280.   (unsigned-reg) (descriptor-reg))
  281.  
  282.  
  283. ;;; Move untagged numbers.
  284. ;;;
  285. (define-vop (word-move)
  286.   (:args (x :target y
  287.         :scs (signed-reg unsigned-reg)
  288.         :load-if (not (location= x y))))
  289.   (:results (y :scs (signed-reg unsigned-reg)
  290.            :load-if (not (location= x y))))
  291.   (:effects)
  292.   (:affected)
  293.   (:note "word integer move")
  294.   (:generator 0
  295.     (move y x)))
  296. ;;;
  297. (define-move-vop word-move :move
  298.   (signed-reg unsigned-reg) (signed-reg unsigned-reg))
  299.  
  300.  
  301. ;;; Move untagged number arguments/return-values.
  302. ;;;
  303. (define-vop (move-word-argument)
  304.   (:args (x :target y
  305.         :scs (signed-reg unsigned-reg))
  306.      (fp :scs (any-reg)
  307.          :load-if (not (sc-is y sap-reg))))
  308.   (:results (y))
  309.   (:note "word integer argument move")
  310.   (:generator 0
  311.     (sc-case y
  312.       ((signed-reg unsigned-reg)
  313.        (move y x))
  314.       ((signed-stack unsigned-stack)
  315.        (storew x fp (tn-offset y))))))
  316. ;;;
  317. (define-move-vop move-word-argument :move-argument
  318.   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
  319.  
  320.  
  321. ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
  322. ;;; descriptor passing location.
  323. ;;;
  324. (define-move-vop move-argument :move-argument
  325.   (signed-reg unsigned-reg) (any-reg descriptor-reg))
  326.